home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / colors.arc / MAKECOLR.PAS < prev    next >
Pascal/Delphi Source File  |  1985-12-09  |  4KB  |  132 lines
  1. type
  2.   mask = array[0..6] of byte ;
  3.   xmit = array[0..6] of real ;
  4.   chlo = array[0..4] of byte ;
  5.  
  6.  
  7. const
  8.   _6845_Index = $3D4 ;
  9.   _6845_Data  = $3D5 ;
  10.   ModeControl = $3D8 ;
  11.   red  : mask = ($00,$40,$04,$C0,$0C,$44,$CC) ;
  12.   green: mask = ($00,$20,$02,$A0,$0A,$22,$AA) ;
  13.   blue : mask = ($00,$10,$01,$90,$09,$11,$99) ;
  14.   BC   : xmit = (1.0,0.75,0.50,0.25,0.0,0.0,0.0) ;
  15.   FC   : xmit = (0.0,0.25,0.50,0.75,1.0,0.0,0.0) ;
  16.   BV   : xmit = (0.0,0.65,0.0,1.0,0.0,0.65,1.0) ;
  17.   FV   : xmit = (0.0,0.0,0.65,0.0,1.0,0.65,1.0) ;
  18.   chctr: chlo = (32,176,177,178,219) ;
  19.   MaxC = 6 ;
  20.  
  21. var
  22.   screen    : array[0..15999,0..1] of byte absolute $B000:$8000 ;
  23.   hue       : array[0..MaxC,0..MaxC,0..MaxC] of byte ;
  24.   inten     : array[0..MaxC,0..MaxC,0..MaxC] of byte ;
  25.   colorfile : file of byte ;
  26.  
  27. function bbght(n:integer):boolean ;
  28. begin
  29.   if (n=3) or (n=6) then bbght := true else bbght := false ;
  30. end ;
  31.  
  32. function bdim(n:integer):boolean ;
  33. begin
  34.   if (n=1) or (n=5) then bdim := true else bdim := false ;
  35. end ;
  36.  
  37. function fbght(n:integer):boolean ;
  38. begin
  39.   if (n=4) or (n=6) then fbght := true else fbght := false ;
  40. end ;
  41.  
  42. function fdim(n:integer):boolean ;
  43. begin
  44.   if (n=2) or (n=5) then fdim := true else fdim := false ;
  45. end ;
  46.  
  47.  
  48.  
  49. function exclude (r,g,b:integer) : boolean ;
  50. var
  51.   ex : boolean ;
  52. begin
  53.   ex := false ;
  54.   if bbght(r) and (bdim(g) or bdim(b)) then ex := true ;
  55.   if fbght(r) and (fdim(g) or fdim(b)) then ex := true ;
  56.   if bbght(g) and (bdim(r) or bdim(b)) then ex := true ;
  57.   if fbght(g) and (fdim(r) or fdim(b)) then ex := true ;
  58.   if bbght(b) and (bdim(g) or bdim(r)) then ex := true ;
  59.   if fbght(b) and (fdim(g) or fdim(r)) then ex := true ;
  60.   exclude := ex ;
  61. end ;
  62.  
  63. procedure noblink ;
  64. begin
  65.   port[$3D8] := 9 ;
  66. end ;
  67.  
  68. var
  69.   r,g,b,i,ir,ig,ib,rm,gm,bm,x  : integer ;
  70.   ri,gi,bi,delta             : real ;
  71.   rdelta,gdelta,bdelta       : real ;
  72.   ch,c : byte ;
  73. begin
  74.   noblink ;
  75.   assign(colorfile,'COLOR.DAT');
  76.   rewrite(colorfile) ;
  77.   for r := 0 to MaxC do
  78.   begin
  79.     for g := 0 to MaxC do
  80.     begin
  81.       for b := 0 to MaxC do
  82.       begin
  83.         TextColor(15) ;
  84.         write('Color ',r,',',g,',',b,' = ');
  85.         ri := r / MaxC ;
  86.         bi := b / MaxC ;
  87.         gi := g / MaxC ;
  88.         rm := 0 ;
  89.         bm := 0 ;
  90.         gm := 0 ;
  91.         ch := 0 ;
  92.         delta := 1e30 ;
  93.         for i := 0 to 4 do
  94.         begin
  95.           for ir := 0 to 6 do
  96.           begin
  97.             for ig := 0 to 6 do
  98.             begin
  99.               for ib := 0 to 6 do
  100.               if not exclude(ir,ig,ib) then
  101.               begin
  102.                 rdelta := abs(BC[i]*BV[ir]+FC[i]*FV[ir]-ri) ;
  103.                 gdelta := abs(BC[i]*BV[ig]+FC[i]*FV[ig]-gi) ;
  104.                 bdelta := abs(BC[i]*BV[ib]+FC[i]*FV[ib]-bi) ;
  105.                 if (rdelta+gdelta+bdelta) < delta then
  106.                 begin
  107.                   rm := ir ;
  108.                   bm := ib ;
  109.                   gm := ig ;
  110.                   ch := i ;
  111.                   delta := rdelta+gdelta+bdelta ;
  112.                 end ;
  113.               end ;
  114.             end ;
  115.           end ;
  116.         end ;
  117.         hue[r,g,b] := red[rm] or blue[bm] or green[gm] ;
  118.         inten[r,g,b] := chctr[ch] ;
  119.         Write(colorfile,hue[r,g,b],inten[r,g,b]) ;
  120.         TextColor(hue[r,g,b] mod 16) ;
  121.         if hue[r,g,b]>127 then TextColor(hue[r,g,b] mod 16+16) ;
  122.         TextBackground((hue[r,g,b] div 16) mod 8) ;
  123.         for x := 1 to 40 do Write(chr(inten[r,g,b])) ;
  124.         TextColor(15) ;
  125.         TextBackground(0) ;
  126.         Writeln(hue[r,g,b],':',inten[r,g,b]) ;
  127.       end ;
  128.     end ;
  129.   end ;
  130.   Close(ColorFile) ;
  131. end .
  132.